home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / glibmm-2.4 / proc / pm / GtkDefs.pm < prev    next >
Encoding:
Perl POD Document  |  2006-04-20  |  14.0 KB  |  636 lines
  1. # gtkmm - GtkDefs module
  2. #
  3. # Copyright 2001 Free Software Foundation
  4. #
  5. # This program is free software; you can redistribute it and/or modify
  6. # it under the terms of the GNU General Public License as published by
  7. # the Free Software Foundation; either version 2 of the License, or 
  8. # (at your option) any later version.
  9. #
  10. # This program is distributed in the hope that it will be useful,
  11. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
  13. # GNU General Public License for more details. 
  14. #
  15. # You should have received a copy of the GNU General Public License
  16. # along with this program; if not, write to the Free Software
  17. # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  18. #
  19. package GtkDefs;
  20. use strict;
  21. use warnings;
  22.  
  23. use Util;
  24. use Enum;
  25. use Object;
  26. use Property;
  27. use FunctionBase;
  28.  
  29. #
  30. #  Public functions
  31. #    read_defs(path, file)
  32. #
  33. #    @ get_methods()
  34. #    @ get_signals()
  35. #    @ get_properties()
  36. #
  37. #    $ lookup_enum(c_type)
  38. #    $ lookup_object(c_name)
  39. #    $ lookup_method(c_name)
  40. #    $ lookup_function(c_name)
  41. #    $ lookup_property(object, c_name)
  42. #    $ lookup_signal(object, c_name)
  43. #
  44.  
  45. BEGIN {
  46.      use Exporter   ();
  47.      our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  48.  
  49.      # set the version for version checking
  50.      $VERSION     = 1.00;
  51.  
  52.      @ISA         = qw(Exporter);
  53.      @EXPORT      = ( );
  54.      %EXPORT_TAGS = ( );
  55.  
  56.      # your exported package globals go here,
  57. #    # as well as any optionally exported functions
  58.      @EXPORT_OK   = ( );
  59. }
  60. our @EXPORT_OK;
  61.  
  62. #####################################
  63.  
  64. use strict;
  65. use warnings;
  66.  
  67. #####################################
  68.  
  69. %GtkDefs::enums = (); #Enum
  70. %GtkDefs::objects = (); #Object
  71. %GtkDefs::methods = (); #GtkDefs::Function
  72. %GtkDefs::signals = (); #GtkDefs::Signal
  73. %GtkDefs::properties = (); #Property
  74.  
  75. @GtkDefs::read = ();
  76. @GtkDefs::file = ();
  77.  
  78.  
  79. #####################################
  80. #prototype to get rid of warning
  81. sub read_defs($$;$);
  82.  
  83. sub read_defs($$;$)
  84. {
  85.   my ($path, $filename, $restrict) = @_;
  86.   $restrict = "" if ($#_ < 2);
  87.  
  88.   # check that the file is there.
  89.   if ( ! -r "$path/$filename")
  90.   {
  91.      print "Error: can't read defs file $filename\n";
  92.      return;
  93.   }
  94.  
  95.   # break the tokens into lisp phrases up to three levels deep.
  96.   #   WARNING: reading the following perl statement may induce seizures,
  97.   #   please flush eyes with water immediately, and consult a mortician.
  98.   my @tokens = split(
  99.     m/(
  100.         \(
  101.         (?:
  102.             [^()]*
  103.             \(
  104.             (?:
  105.                 [^()]*
  106.                 \(
  107.                 [^()]+
  108.                 \)
  109.             )*
  110.             [^()]*
  111.             \)
  112.         )*
  113.         [^()]*
  114.         \)
  115.     )/x,
  116.     read_file($path, $filename));
  117.  
  118.   # scan through top level tokens
  119.   while ($#tokens > -1)
  120.   {
  121.     my $token = shift @tokens;
  122.     next if ($token =~ /^\s*$/);
  123.  
  124.     if ($token =~ /\(include (\S+)\)/)
  125.     {
  126.       read_defs($path,$1,$restrict);
  127.       next;
  128.     }
  129.     elsif ($token =~ /^\(define-flags-extended.*\)$/)
  130.     { on_enum($token); }
  131.     elsif ($token =~ /^\(define-enum-extended.*\)$/)
  132.     { on_enum($token); }
  133.     elsif ($token =~ /^\(define-flags.*\)$/)
  134.     { }
  135.     elsif ($token =~ /^\(define-enum.*\)$/)
  136.     { }
  137.     elsif ($token =~ /^\(define-object.*\)$/)
  138.     { on_object($token); }
  139.     elsif ($token =~ /^\(define-function.*\)$/)
  140.     { on_function($token); }
  141.     elsif ($token =~ /^\(define-method.*\)$/)
  142.     { on_method($token); }
  143.     elsif ($token =~ /^\(define-property.*\)$/)
  144.     { on_property($token); }
  145.     elsif ($token =~ /^\(define-signal.*\)$/)
  146.     { on_signal($token);  }
  147.     elsif ($token =~ /^\(define-vfunc.*\)$/)
  148.     { on_vfunc($token); }
  149.     else
  150.     {
  151.       if ( $token =~ /^\(define-(\S+) (\S+)/)
  152.       {
  153.         # FIXME need to figure out the line number.
  154.         print STDERR "Broken lisp definition for $1 $2.\n";
  155.       }
  156.       else
  157.       {
  158.         print "unknown token $token \n";
  159.       }
  160.     }
  161.   }
  162. }
  163.  
  164.  
  165. sub read_file($$)
  166. {
  167.   my ($path, $filename)=@_;
  168.   my @buf = ();
  169.  
  170.   # don't read a file twice
  171.   foreach (@GtkDefs::read)
  172.   {
  173.     return "" if ($_ eq "$path/$filename");
  174.   }
  175.   push @GtkDefs::read, "$path/$filename";
  176.  
  177.   # read file while stripping comments
  178.   open(FILE, "$path/$filename");
  179.   while (<FILE>)
  180.   {
  181.      s/^;.*$//;  # remove comments
  182.      chop;      # remove new lines
  183.      push(@buf, $_);
  184.   }
  185.   close(FILE);
  186.  
  187.   $_ = join("", @buf);
  188.   s/\s+/ /g;
  189.   return $_;
  190. }
  191.  
  192.  
  193. sub on_enum($)
  194. {
  195.   my $thing = Enum::new(shift(@_));
  196.   $GtkDefs::enums{$$thing{c_type}} = $thing;
  197. }
  198.  
  199. sub on_object($)
  200. {
  201.   my $thing = Object::new(shift(@_));
  202.   $GtkDefs::objects{$$thing{c_name}} = $thing;
  203. }
  204.  
  205. sub on_function($)
  206. {
  207.   my $thing = GtkDefs::Function::new(shift(@_));
  208.   $GtkDefs::methods{$$thing{c_name}} = $thing;
  209. }
  210.  
  211. sub on_method($)
  212. {
  213.   my $thing = GtkDefs::Function::new(shift(@_));
  214.   $GtkDefs::methods{$$thing{c_name}} = $thing if ($thing);
  215. }
  216.  
  217. sub on_property($)
  218. {
  219.   my $thing = Property::new(shift(@_));
  220.   $GtkDefs::properties{"$$thing{class}::$$thing{name}"} = $thing;
  221. }
  222.  
  223. sub on_signal($)
  224. {
  225.   my $thing = GtkDefs::Signal::new(shift(@_));
  226.   $GtkDefs::signals{"$$thing{class}::$$thing{name}"} = $thing;
  227. }
  228.  
  229. sub on_vfunc($)
  230. {
  231.   my $thing = GtkDefs::Signal::new(shift(@_));
  232.   $GtkDefs::signals{"$$thing{class}::$$thing{name}"} = $thing;
  233. }
  234.  
  235. ##########################
  236.  
  237. sub get_enums
  238. {
  239.   return sort {$$a{c_type} cmp $$b{c_type}} values %GtkDefs::enums;
  240. }
  241. sub get_methods
  242. {
  243.   return sort {$$a{c_name} cmp $$b{c_name}} values %GtkDefs::methods;
  244. }
  245. sub get_signals
  246. {
  247.   return sort {$$a{name} cmp $$b{name}} values %GtkDefs::signals;
  248. }
  249. sub get_properties
  250. {
  251.   return sort {$$a{name} cmp $$b{name}} values %GtkDefs::properties;
  252. }
  253.  
  254. sub get_marked
  255. {
  256.   no warnings;
  257.   return grep {$$_{mark}==1} values %GtkDefs::methods; 
  258. }
  259.  
  260. # This searches for items wrapped by this file and then tries to locate
  261. # other functions/signal/properties which may have been left unmarked.
  262. sub get_unwrapped
  263. {
  264.   # find methods which were used in for a _WRAP
  265.   my @targets;
  266.   push @targets,grep {$$_{entity_type} eq "method" && $$_{mark}==1} values %GtkDefs::methods;
  267.   push @targets,grep {$$_{mark}==1} values %GtkDefs::signals;
  268.   push @targets,grep {$$_{mark}==1} values %GtkDefs::properties;
  269.  
  270.   # find the classes which used them.
  271.   my @classes = join(" ", unique(map { $$_{class} } @targets));
  272.  
  273.   # find methods which are in those classes which didn't get marked.
  274.   my @unwrapped;
  275.   my $class;
  276.   foreach $class (@classes)
  277.   {
  278.     push @unwrapped, grep {$$_{class} eq $class && $$_{mark}==0} values %GtkDefs::methods;
  279.     push @unwrapped, grep {$$_{class} eq $class && $$_{mark}==0} values %GtkDefs::properties;
  280.     push @unwrapped, grep {$$_{class} eq $class && $$_{mark}==0} values %GtkDefs::signals;
  281.   }
  282.  
  283.   return @unwrapped;
  284. }
  285.  
  286. ##########################
  287.  
  288. sub lookup_enum($)
  289. {
  290.   no warnings;
  291.   my ($c_type) = @_;
  292.   my $obj = $GtkDefs::enums{$c_type};
  293.   return 0 if(!$obj);
  294.   $$obj{mark} = 1;
  295.   return $obj;
  296. }
  297.  
  298. sub lookup_object($)
  299. {
  300.   no warnings;
  301.   return $GtkDefs::objects{$_[0]};
  302. }
  303.  
  304. # $objProperty lookup_property($name, $parent_object_name)
  305. sub lookup_property($$)
  306. {
  307.   no warnings;
  308.   my ($parent_object_name, $name) = @_;
  309.   $name =~ s/-/_/g;
  310.   my $obj = $GtkDefs::properties{"${parent_object_name}::${name}"};
  311.   return 0 if ($obj eq "");
  312.   $$obj{mark} = 1;
  313.   return $obj;
  314. }
  315.  
  316. sub lookup_method_dont_mark($)
  317. {
  318.   no warnings;
  319.   my ($c_name) = @_;
  320.   $c_name =~ s/-/_/g;
  321.  
  322.   my $obj = $GtkDefs::methods{$c_name};
  323.   return 0 if ($obj eq "");
  324.  
  325.   return $obj;
  326. }
  327.  
  328. sub lookup_method($)
  329. {
  330.   my $obj = lookup_method_dont_mark($_);
  331.  
  332.   $$obj{mark} = 1 if($obj);
  333.   return $obj;
  334. }
  335.  
  336. sub lookup_function($)
  337. {
  338.   return lookup_method($_[0]);
  339. }
  340.  
  341. sub lookup_signal($$)
  342. {
  343.   no warnings;
  344.   my ($parent_object_name, $name) = @_;
  345.  
  346.   $name =~ s/-/_/g;
  347.   my $obj = $GtkDefs::signals{"${parent_object_name}::${name}"};
  348.   return 0 if ($obj eq "");
  349.   $$obj{mark} = 1;
  350.   return $obj;
  351. }
  352.  
  353. sub error
  354. {
  355.   my $format = shift @_;
  356.   printf STDERR "GtkDefs.pm: $format\n", @_;
  357. }
  358.  
  359.  
  360. ########################################################################
  361. package GtkDefs::Function;
  362. BEGIN { @GtkDefs::Function::ISA=qw(FunctionBase); }
  363.  
  364. #  class Function : FunctionBase
  365. #
  366. #    {
  367. #       string name; e.g. gtk_accelerator_valid
  368. #       string c_name;
  369. #       string class e.g. GtkButton 
  370. #
  371. #       string rettype;
  372. #       string array param_types;
  373. #       string array param_names;
  374. #
  375. #       string entity_type. e.g. method or signal
  376. #
  377. #       bool varargs;
  378. #       bool mark;
  379. #
  380. #    }
  381.  
  382. # "new" can't have prototype
  383. sub new
  384. {
  385.   my ($def) = @_;
  386.   my $whole = $def;
  387.   my $self = {};
  388.   bless $self;
  389.  
  390.   $def =~ s/^\(//;
  391.   $def =~ s/\)$//;
  392.   $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//;
  393.   $$self{entity_type} = $1;
  394.   $$self{name} = $2;
  395.   $$self{name} =~ s/-/_/g; # change - to _
  396.  
  397.   # init variables
  398.   $$self{mark} = 0;
  399.   $$self{rettype} = "none";
  400.   $$self{param_types} = [];
  401.   $$self{param_names} = [];
  402.   $$self{class} = "";
  403.  
  404.   # snarf down lisp fields
  405.   $$self{c_name} = $1     if ($def=~s/\(c-name "(\S+)"\)//);
  406.   $$self{class} = $1      if ($def=~s/\(of-object "(\S+)"\)//);
  407.  
  408.   if ($def =~ s/\(return-type "(\S+)"\)//)
  409.   {
  410.     $$self{rettype} = $1;
  411.     $$self{rettype} =~ s/-/ /g; #e.g. replace const-gchar* with const gchar*. Otherwise it will be used in code.
  412.   }
  413.  
  414.   $$self{varargs} = 1     if ($def=~s/\(varargs\s+#t\)//);
  415.   $$self{rettype} = "void"  if ($$self{rettype} eq "none");
  416.  
  417.   # methods have a parameter not stated in the defs file
  418.   if ($$self{entity_type} eq "method")
  419.   {
  420.     push( @{$$self{param_types}}, "$$self{class}*" );
  421.     push( @{$$self{param_names}}, "self" );
  422.   }
  423.  
  424.   # parameters are compound lisp statement
  425.   if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))*) \)//)
  426.   {
  427.     $self->parse_param($1);
  428.   }
  429.  
  430.   # is-constructor-of:
  431.   if ($def =~ s/\(is-constructor-of "(\S+)"\)//)
  432.   {
  433.     #Ignore them.
  434.   }
  435.   
  436.   # of-object
  437.   if ($def =~ s/\(of-object "(\S+)"\)//)
  438.   {
  439.     #Ignore them.
  440.   }
  441.  
  442.   GtkDefs::error("Unhandled function parameter ($def) in $$self{c_name}\n")
  443.     if ($def !~ /^\s*$/);
  444.  
  445.   return $self;
  446. }
  447.  
  448. sub parse_param($$)
  449. {
  450.   my ($self, $param) = @_;
  451.  
  452.   # break up the parameter statements
  453.   foreach (split(/\s*'*[()]\s*/, $param))
  454.   {
  455.     next if ($_ eq "");
  456.     if (/^"(\S+)" "(\S+)"$/)
  457.     {
  458.       my ($p1, $p2) = ($1,$2);
  459.       $p1 =~ s/-/ /;
  460.       push( @{$$self{param_types}}, $p1);
  461.       push( @{$$self{param_names}}, $p2);
  462.     }
  463.     else
  464.     {
  465.       GtkDefs::error("Unknown parameter statement ($_) in $$self{c_name}\n");
  466.     }
  467.   }
  468. }
  469.  
  470.  
  471. # $string get_return_type_for_methods().
  472. # Changes gchar* (not const-gchar*) to return-gchar* so that _CONVERT knows that it needs to be freed.
  473. sub get_return_type_for_methods($)
  474. {
  475.   my ($self) = @_;
  476.  
  477.   my $rettype = $$self{rettype};
  478.   if($rettype eq "gchar*" || $rettype eq "char*")
  479.   {
  480.     $rettype = "return-" . $rettype;
  481.   }
  482.  
  483.   return $rettype;
  484. }
  485.  
  486. sub get_param_names
  487. {
  488.   my ($self) = @_;
  489.   return @$self{param_names};
  490. }
  491.  
  492. ######################################################################
  493. package GtkDefs::Signal;
  494. BEGIN { @GtkDefs::Signal::ISA=qw(GtkDefs::Function); }
  495.  
  496. #  class Signal : Function
  497. #    {
  498. #       string name; e.g. gtk_accelerator_valid
  499. #       string class e.g. GtkButton ( == of-object.)
  500. #
  501. #       string rettype;
  502. #
  503. #       string when. e.g. first, last, or both.
  504. #       string entity_type. e.g. method or signal
  505. #    }
  506.  
  507. # "new" can't have prototype
  508. sub new
  509. {
  510.   my ($def) = @_;
  511.  
  512.   my $whole = $def;
  513.   my $self = {};
  514.   bless $self;
  515.  
  516.   #Remove first and last braces:
  517.   $def =~ s/^\(//;
  518.   $def =~ s/\)$//;
  519.  
  520.   $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//;
  521.   $$self{entity_type} = $1;
  522.   $$self{name} = $2;
  523.   $$self{name} =~ s/-/_/g; #change - to _
  524.  
  525.   # init variables
  526.   $$self{mark}=0;
  527.   $$self{rettype} = "none";
  528.   $$self{param_types} = [];
  529.   $$self{param_names} = [];
  530.   $$self{when} = "";
  531.   $$self{class} = "";
  532.  
  533.   # snarf down lisp fields
  534.   if($def =~ s/\(of-object "(\S+)"\)//)
  535.   {
  536.     $$self{class} = $1;
  537.   }
  538.   else
  539.   {
  540.     GtkDefs::error("define-signal/define-vfunc without of-object (entity type: $$self{entity_type}): $whole");
  541.   }
  542.  
  543.   if($def =~ s/\(return-type "(\S+)"\)//)
  544.   {
  545.     $$self{rettype} = $1;
  546.     $$self{rettype} =~ s/-/ /g; #e.g. replace const-gchar* with const gchar*. Otherwise it will be used in code.
  547.   }
  548.  
  549.   if($def =~ s/\(when "(\S+)"\)//)
  550.   {
  551.     $$self{when} = $1;
  552.   }
  553.  
  554.   if($$self{rettype} eq "none")
  555.   {
  556.     $$self{rettype} = "void"
  557.   }
  558.  
  559.   # signals always have a parameter
  560.   push(@{$$self{param_types}}, "$$self{class}*");
  561.   push(@{$$self{param_names}}, "self");
  562.  
  563.   # parameters are compound lisp statement
  564.   if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))+) \)//)
  565.   {
  566.     $self->parse_param($1);
  567.   }
  568.  
  569.   if ($def!~/^\s*$/)
  570.   {
  571.       GtkDefs::error("Unhandled signal/vfunc def ($def) in $$self{class}::$$self{name}");
  572.   }
  573.  
  574.   return $self;
  575. }
  576.  
  577. # bool has_same_types($objFunction)
  578. # Compares return types and argument types
  579. sub has_same_types($$)
  580. {
  581.   my ($self, $objFuncOther) = @_;
  582.  
  583.   #Compare return types:
  584.   if($self->types_are_equal($$self{rettype}, $$objFuncOther{rettype}) ne 1)
  585.   {
  586.     # printf("debug: different return types: %s, %s\n", $$self{rettype}, $$objFuncOther{rettype});
  587.     return 0; #Different types found.
  588.   }
  589.  
  590.   #Compare arguement types:
  591.   my $i = 0;
  592.   my $param_types = $$self{param_types};
  593.   my $param_types_other = $$objFuncOther{param_types};
  594.   for ($i = 1; $i < $#$param_types + 1; $i++)
  595.   {
  596.     my $type_a = $$param_types[$i];
  597.     my $type_b = $$param_types_other[$i-1];
  598.  
  599.     if($self->types_are_equal($type_a, $type_b) ne 1)
  600.     {
  601.       # printf("debug: different arg types: %s, %s\n", $type_a, $type_b);
  602.       return 0; #Different types found.
  603.     }
  604.   }
  605.  
  606.   return 1; #They must all be the same for it to get this far.
  607. }
  608.  
  609. # bool types_are_equal($a, $b)
  610. # Compares types, ignoring gint/int differences, etc.
  611. sub types_are_equal($$$)
  612. {
  613.   #TODO: Proper method of getting a normalized type name.
  614.  
  615.   my ($self, $type_a, $type_b) = @_;
  616.  
  617.   if($type_a ne $type_b)
  618.   {
  619.     #Try adding g to one of them:
  620.     if( ("g" . $type_a) ne $type_b )
  621.     {
  622.       #Try adding g to the other one:
  623.       if( $type_a ne ("g" . $type_b) )
  624.       {
  625.         #After all these checks it's still not equal:
  626.         return 0; #not equal.
  627.       }
  628.     }
  629.   }
  630.  
  631.   # printf("DEBUG: types are equal: %s, %s\n", $$type_a, $$type_b);
  632.   return 1; #They must be the same for it to get this far.
  633. }
  634.  
  635. 1; # indicate proper module load.
  636.